(* ===================================================================== *)
(** Application bopin : generation d'entrees pipe01 en meta a partir 
    d'un fichier bpi indiquant ou chercher les valeurs des inputs.
    @author Mathieu Barbin
    @version 1.0.* *)
(* ===================================================================== *)

(*
  Utilise les Metatools, en commun avec bopipe.
*)

open Message
open Inputtools
open Metatools

(* ===================================================================== *)
(** Lexer/Parser d'un fichier BPI *)
(* ===================================================================== *)
let bpi_of_file filename =
  try
    let ic = open_in filename in
    let buff = Lexing.from_channel ic in
    let youpi = ParserBPI.input LexerBPI.lexem_list buff
    in
    begin
      close_in ic;
      youpi
    end
  with
  | Sys_error _ -> 
      message#bpi_file_introuvable filename;
      failwith "w-friendly"
  | Parsing.Parse_error ->
      message#syntax_error filename (!index_ligne_bpi_file); 
      failwith "w-friendly"
  | Failure m -> 
      message#syntax_error_message m filename (!index_ligne_bpi_file); 
      failwith "w-friendly"
(* ===================================================================== *)

(* ===================================================================== *)
(** Dans un bopin, on est assuré qu'il n'y a pas de variables d'entrees *)
(* ===================================================================== *)
let ocaml_entete_of_interface_out filename vars_out = 
  ocaml_entete_of_interface false false filename [] vars_out

(* ===================================================================== *)
(** Meta production d'appel d'une fonction bool array pour dimension n *)
(* ===================================================================== *)
let prod_assign_signal_array fct tab_name tab =
  let n = Array.length tab in
  (* Allocation d'un tableau de bool de dimension n > 1 *)
  let rec aux i =
    if i = pred n 
    then
      Printf.sprintf "%s %s;" fct (acces_n tab_name "i" (pred n))
    else
      Printf.sprintf "for i%d = 0 to pred %s do %s done;" i tab.(i) (aux (succ i)) 
  in 
  (aux 0)^"\n";;
(* ===================================================================== *)

(* ===================================================================== *)
(** Production du code de lecture 
    Etant donnee la liste de description des entrees, et la liste des 
    variables bp de l'interface, on produit 2 files qui contiennent 
    respectivement le code de declaration des objets de lecture, 
    et le code des appels. *)
(* ===================================================================== *)
let queues_lecture filename env vars_out declarations_list = 
  let object_decl = Queue.create () and code_lecture = Queue.create () in
  let assoc_decl vars = 
    List.map 
      (function | (VBit s) as e -> (s, e) | (VWord (s, _)) as e -> (s, e)) vars
  in
  let vars_out_assoc = assoc_decl vars_out in
  let specifiees = ref [] in
  let rec parcours_decl index = function
    | [] -> ()
    | (line, d)::q -> 
	let input_name = Printf.sprintf "input%d" index in
	begin
	  let v_decl = List.map (bp_var_of_var env) d.input_net_vars in
	  (
	  match d.type_des with
	  | Text t -> 
	      let od = Printf.sprintf "let %s = new Bplib.StdInput.of_string \"%s\";;\n%s#init;;\n" input_name t input_name in 
	      Queue.add od object_decl;
	      let rec aux = function
		| [] -> ()
		| (VBit s)::q ->  
		    if List.mem_assoc s vars_out_assoc 
		    then
		      begin
			if List.mem s !specifiees
			then 
			  begin
			    Message.message#definition_multiple_input filename line s;
			    failwith "w-friendly"
			  end
			else
			  specifiees := s::(!specifiees);
			match List.assoc s vars_out_assoc with
			| VBit s' -> 
			    (* s est un simple bit *)
			    let assign = Printf.sprintf "%s#set_ref %s;\n" input_name s' in
			    Queue.add assign code_lecture;
			    aux q
			| VWord (s', it') ->
			    (* s est en fait un array de dimension length(it') *) 
			    let assign = prod_assign_signal_array (input_name^"#set_array ") s' it' in
			    Queue.add assign code_lecture;
			    aux q
		      end
		    else 
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end
		| (VWord (s, _))::_ ->
		    if List.mem_assoc s vars_out_assoc
		    then
		      begin
			(* Dans une prochaine version, on peut autoriser les indexations
			   dans les liaisons des entrees : mais dans 1.0.*, non.*)
			Message.message#entree_type_error filename line s;
			failwith "w-friendly"
		      end
		    else
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end 
	      in aux v_decl
	  | File f ->
	      let od = Printf.sprintf "let %s = new Bplib.StdInput.of_asci_file \"%s\";;\n%s#init;;\n" input_name f input_name in 
	      Queue.add od object_decl;
	      let rec aux = function
		| [] -> ()
		| (VBit s)::q ->
		    if List.mem_assoc s vars_out_assoc 
		    then
		      begin
			if List.mem s !specifiees
			then 
			  begin
			    Message.message#definition_multiple_input filename line s;
			    failwith "w-friendly"
			  end
			else
			  specifiees := s::(!specifiees); 
			match List.assoc s vars_out_assoc with
			| VBit s' -> 
			    (* s est un simple bit *)
			    let assign = Printf.sprintf "%s#set_ref %s;\n" input_name s' in
			    Queue.add assign code_lecture;
			    aux q
			| VWord (s', it') ->
			    (* s est en fait un array de dimension length(it') *) 
			    let assign = prod_assign_signal_array (input_name^"#set_array ") s' it' in
			    Queue.add assign code_lecture;
			    aux q
		      end
		    else 
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end
		| (VWord (s, _))::_ ->
		    if List.mem_assoc s vars_out_assoc
		    then
		      begin
			(* Dans une prochaine version, on peut autoriser les indexations
			   dans les liaisons des entrees : mais dans 1.0.*, non.*)
			Message.message#entree_type_error filename line s;
			failwith "w-friendly"
		      end
		    else
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end 
	      in aux v_decl
	  | BinaryFile f -> 
	      let od = Printf.sprintf "let %s = new Bplib.StdInput.of_bin_file \"%s\";;\n%s#init;;\n" input_name f input_name in 
	      Queue.add od object_decl;
	      let rec aux = function
		| [] -> ()
		| (VBit s)::q ->
		    if List.mem_assoc s vars_out_assoc 
		    then
		      begin
			if List.mem s !specifiees
			then 
			  begin
			    Message.message#definition_multiple_input filename line s;
			    failwith "w-friendly"
			  end
			else
			  specifiees := s::(!specifiees);
			match List.assoc s vars_out_assoc with
			| VBit s' -> 
			    (* s est un simple bit *)
			    let assign = Printf.sprintf "%s#set_ref %s;\n" input_name s' in
			    Queue.add assign code_lecture;
			    aux q
			| VWord (s', it') ->
			    (* s est en fait un array de dimension length(it') *) 
			    let assign = prod_assign_signal_array (input_name^"#set_array ") s' it' in
			    Queue.add assign code_lecture;
			    aux q
		      end
		    else 
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end
		| (VWord (s, _))::_ ->
		    if List.mem_assoc s vars_out_assoc
		    then
		      begin
			(* Dans une prochaine version, on peut autoriser les indexations
			   dans les liaisons des entrees : mais dans 1.0.*, non.*)
			Message.message#entree_type_error filename line s;
			failwith "w-friendly"
		      end
		    else
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end 
	      in aux v_decl
	  | Counter ->
	      let f_fold accu = function
		| VBit s ->
		    if List.mem_assoc s vars_out_assoc
		    then
		      begin
			if List.mem s !specifiees
			then 
			  begin
			    Message.message#definition_multiple_input filename line s;
			    failwith "w-friendly"
			  end
			else
			  specifiees := s::(!specifiees);
			match List.assoc s vars_out_assoc with
			| VBit s' -> 
			    begin
			      let assign = Printf.sprintf "%s#set_ref %s;\n" input_name s' in
			      Queue.add assign code_lecture;
			      Printf.sprintf "%s + 1" accu
			    end
			| VWord (s', it') -> 
			    begin
			      let assign = prod_assign_signal_array (input_name^"#set_array ") s' it' in
			      Queue.add assign code_lecture;
			      Printf.sprintf "%s + %s" accu ("("^(fold_init (fun accu i -> (Printf.sprintf "%s * %s" accu it'.(i))) "1" (Array.length it'))^")")
			    end
		      end
		    else 
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end
		| VWord (s, _) ->
		    (* Dans une prochaine version, on peut autoriser les indexations
		       dans les liaisons des entrees : mais dans 1.0.*, non.*)
		    Message.message#entree_type_error filename line s;
		    failwith "w-friendly"
	      in
	      let nb_count = List.fold_left f_fold "0" v_decl in
	      let od = Printf.sprintf "let %s = new Bplib.StdInput.counter (%s);;\n%s#init;;\n" input_name nb_count input_name in
	      Queue.add od object_decl     
	  | UnitFun (linef, f) ->
	      let od0 = Printf.sprintf "# %d \"%s\"\n" (linef - (num_line f)) filename
	      and od1 = Printf.sprintf "let %s = new Bplib.StdInput.of_unit_fun (" input_name 
	      and od2 = Printf.sprintf "%s);;\n%s#init;;\n" f input_name in 
	      Queue.add (od0^od1^od2) object_decl;
	      let rec aux = function
		| [] -> ()
		| (VBit s)::q ->
		    if List.mem_assoc s vars_out_assoc 
		    then
		      begin
			if List.mem s !specifiees
			then 
			  begin
			    Message.message#definition_multiple_input filename line s;
			    failwith "w-friendly"
			  end
			else
			  specifiees := s::(!specifiees);
		      match List.assoc s vars_out_assoc with
		      | VBit s' -> 
			  (* s est un simple bit *)
			  let assign = Printf.sprintf "%s#set_ref %s;\n" input_name s' in
			  Queue.add assign code_lecture;
			  aux q
		      | VWord (s', it') ->
			  (* s est en fait un array de dimension length(it') *) 
			  let assign = prod_assign_signal_array (input_name^"#set_array ") s' it' in
			  Queue.add assign code_lecture;
			  aux q
		      end
		    else 
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end
		| (VWord (s, _))::_ ->
		    if List.mem_assoc s vars_out_assoc
		    then
		      begin
			(* Dans une prochaine version, on peut autoriser les indexations
			   dans les liaisons des entrees : mais dans 1.0.*, non.*)
			Message.message#entree_type_error filename line s;
			failwith "w-friendly"
		      end
		    else
		      begin
			Message.message#entree_non_declaree filename line s;
			failwith "w-friendly"
		      end 
	      in aux v_decl
	  | ArgFun f -> failwith "TODO ArgFun in Bopin"
	  );
	  parcours_decl (succ index) q
	end
  in
  begin
    parcours_decl 0 declarations_list;
    let f_iter v = 
      let s = match v with  
      | VBit e -> e
      | VWord (e, _) -> e in
      if not (List.mem s (!specifiees))
      then Message.message#entree_non_specifiee filename s
      else ()
    in
    List.iter f_iter vars_out;
    object_decl, code_lecture
  end
  
(* ===================================================================== *)

(* ===================================================================== *)
(** Produire le code ocaml correspondant au .bpi *)
(* ===================================================================== *)
let programme_of_bpi_file filename oc =
  (* Garder un controle sur les numéros de ligne pour pouvoir gérer les 
     messages d'erreur d'ocamlopt pour rediriger sur la bonne ligne *)
  let index_meta_ligne = ref 1 in
  let produce_code c = 
    let new_line = num_line c in
    begin
      Printf.fprintf oc "%s" c;
      index_meta_ligne := (!index_meta_ligne) + new_line
    end
  in
  let (source, setCPS, macros, (lineInit, init), interface, descriptions_entrees) = bpi_of_file filename in
  let debutInit = lineInit - (num_line init) in
  let env = env_macros_of_macros_BP filename macros in
  let name_input, vars_out = 
    match interface with
    | InputExt (name_input, vout) ->
	name_input , (List.map (bp_var_of_var env) vout)
  in
  verifie_ocaml_vars filename name_input vars_out;
  let object_decl, code_lecture = queues_lecture filename env vars_out descriptions_entrees in
  match (bp_source_of_string source) with
  | Ocaml ->
      begin
	prerr_endline "TARGET = ocaml";
	produce_code (Printf.sprintf "(* Programme ocaml macro-généré par bopin %s : %s*)\n" Message.version (Message.get_date ()));
	produce_code "(* A compiler avec ocamlopt, puis a piper sur l'entree de bopsimu *)\n\n";
	produce_code "open BplibTypes\n";
	produce_code "open Bplib\n";
	produce_code "let args = Array.to_list Sys.argv;;\n";
	produce_code "let verbose = List.mem \"-v\" args;;\n";
	produce_code "let waiting = not (List.mem \"-ni\" args);;\n";
	produce_code (Printf.sprintf "\n%s%s\n" stdlibBP (ocaml_macro filename macros));
	(match setCPS with
	 | Some cps -> produce_code (Printf.sprintf "let pause = new Bplib.sleeper (1./.(float_of_int %d)) false;;\n" cps)
	 | None -> ()
	);
	produce_code "let index_cycle = ref 0;;\n";
	produce_code (Printf.sprintf "(* FROM %s [%d] : INIT (%d - %d) *)\n" (String.uppercase filename) debutInit (!index_meta_ligne + 2) (!index_meta_ligne + 2 + (num_line init)));
	produce_code (Printf.sprintf "# %d \"%s\"\n" debutInit filename);

	produce_code (Printf.sprintf "%s\n(* END FROM INIT *)let end_init = true;;\n" init);
	produce_code (Printf.sprintf "# %d \"_tmp.ml\"\n" (!index_meta_ligne + 1));
	produce_code "(* ouverture des fichiers, creation des objets de lecture *)\n";
	let f_iter s = 
	  begin
	    produce_code s;
	    produce_code (Printf.sprintf "# %d \"_tmp.ml\"\n" (!index_meta_ligne + 1));
	  end
	in
	Queue.iter f_iter object_decl;
	produce_code "\n";
	produce_code (Printf.sprintf "# %d \"_tmp.ml\"\n" (!index_meta_ligne + 1));
	produce_code "try\n"; 
	produce_code (Printf.sprintf "  prerr_endline \"This is \\\"%s\\\" by bopin %s\";\n" filename version);
	produce_code (ocaml_entete_of_interface_out filename vars_out); 
	produce_code "  while true do\n";
	(match setCPS with
	 | Some _ -> produce_code "    pause#sleep;\n"
	 | None -> ()
	);
	produce_code "    begin\n\n";
	Queue.iter produce_code code_lecture;
	produce_code "\n";
	produce_code "    end;\n";
	produce_code "\n(* Vers stdout selon le protocole pipe 01 *)\n";
	produce_code "    if waiting then ignore (input_line stdin) else ();\n";
	produce_code (ocaml_traitement_stdout vars_out);
	produce_code "\n    print_newline (); flush stdout;\n";
	produce_code "    incr(index_cycle);\n"; 
	produce_code "  done\n";
	produce_code "with\n";
        produce_code "  | End_of_file -> ()\n";
    end 
  | C -> 
      begin
	failwith "TODO bopin in C"
      end
  | Autre lg ->
      begin
	Message.message#autre_langage "bopin" lg;
	failwith "w-friendly"
      end
  | Inconnu lg -> 
      begin
	Message.message#langage_inconnu "bopin" lg;
	failwith "w-friendly"
      end
(* ===================================================================== *)


let _ =
  let len = Array.length Sys.argv in
  Message.message#thisis "bopin";
  if len < 2
  then
    begin
      Printf.fprintf stderr "use : %s myfile.bpi > result.ml\n" Sys.argv.(0);
      exit(1)
    end
  else programme_of_bpi_file Sys.argv.(1) stdout


